home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Tech Arsenal 1
/
Tech Arsenal (Arsenal Computer).ISO
/
tek-02
/
faq-s.zip
/
FILE2.PAS
< prev
next >
Wrap
Pascal/Delphi Source File
|
1991-05-04
|
24KB
|
717 lines
var ud:udrec;
curarea:integer;
offliney,vcr:boolean;
validprotos:set of char;
xtype:char;
procedure beepbeep (ok:integer);
begin
delay (500);
write (^B^M);
case ok of
0:write ('Xfer completed!');
1:write ('Xfer Aborted just before EOF!');
2:write ('Xfer Aborted!')
end;
writeln (^G^M)
end;
procedure seekafile (n:integer);
begin
seek (afile,n-1)
end;
function numareas:integer;
begin
numareas:=filesize (afile)
end;
procedure seekudfile (n:integer);
begin
seek (udfile,n-1)
end;
function numuds:integer;
begin
numuds:=filesize (udfile)
end;
procedure assignud;
begin
{close (udfile);}
assign (udfile,datadir+'AREA'+strr(curarea)+'.'+strr(conn));
close (udfile);
end;
{procedure openudfile;
var n:integer;
begin
n:=ioresult;
assignud;
reset (udfile);
if ioresult<>0 then begin
close (udfile);
n:=ioresult;
rewrite (udfile)
end
end;}
function sponsoron:boolean;
begin
sponsoron:=match(area.sponsor,unam) or issysop
end;
function getapath:lstr;
begin
getapath:=area.xmodemdir;
getapath:=getpath (area.xmodemdir);
end;
{function makearea:boolean;
var num,n:integer;
a:arearec;
begin
makearea:=false;
num:=numareas+1;
n:=numareas;
writestr ('Create Area '+strr(num)+'? [y/n]: *');
if yes then begin
writestr ('Area Name: &');
if length(input)=0 then exit;
a.name:=input;
writestr ('Access Level:');
if length(input)=0 then exit;
a.level:=valu(input);
writestr ('Sponsor [CR/'+unam+']:');
if length(input)=0 then input:=unam;
a.sponsor:=input;
writestr ('Entry Password [CR/None]:');
if length(input)=0 then a.areapw:='' else
a.areapw:=input;
writestr ('Able to Upload into this area? [CR/Yes]:');
if (length(input)=0) or (upcase(input[1])='Y') then
a.upload:=true else a.upload:=false;
writestr ('Able to Download from this area? [CR/Yes]:');
if (length(input)=0) or (upcase(input[1])='Y') then
a.download:=true else a.download:=false;
a.xmodemdir:=getapath;
seekafile (num);
write (afile,a);
area:=a;
curarea:=num;
assignud;
rewrite (udfile);
writeln ('Area created');
makearea:=true;
writelog (15,4,a.name)
end;
end;}
Function makearea:Boolean;
Var num,n:Integer;
a:arearec;
Begin
makearea:=False;
num:=numareas+1;
n:=numareas;
writestr('Create area '+^S+strr(num)+^P+'? [y/N]: *');
If yes Then Begin
if ansigraphics in urec.config then begin
clearscr;
WriteLn(^R' ┌────────────'^P'['^S' FAQ File Area Installation '^P']'^R'───────────┐');
WriteLn(^R' │ │');
WriteLn(^R' │ │');
WriteLn(^R' │ │');
WriteLn(^R' │ │');
WriteLn(^R' │ │');
WriteLn(^R' │ │');
WriteLn(^R' │ │');
{WriteLn(^R' │ │');
WriteLn(^R' │ │');}
WriteLn(^R' └─────────────────────────────────────────────────────┘');
PrintXy(12,8,^P'Upload Path');
PrintXy(12,7,^P'Co-SysOp/Sponsor ['^S+unam+^P']: ');
PrintXy(12,6,^P'Area Password ['^S'CR/None'^P']: ');
PrintXy(12,5,^P'Allow Downloads? ['^S'N'^P']: ');
PrintXy(12,4,^P'Allow Uploads? ['^S'N'^P']: ');
{PrintXy(12,5,^P'Group List File Name ['^S'CR/None'^P']: ');}
PrintXy(12,3,^P'Access Level: ');
{PrintXy(12,3,^P'['^S'G'^P']roup, ['^S'L'^P']evel or ['^S'B'^P']oth access ['^S'L'^P']:');}
PrintXy(12,2,^P'Area Name: ');
movexy(12,2);
writestr(^P'Area Name:');
If Length(Input)=0 Then exit;
a.name:=Input;
{ANSiGoToXy(12,3);
writestr(^P'['^S'G'^P']roup, ['^S'L'^P']evel or ['^S'B'^P']oth access ['^S'L'^P']:');
If Length(Input)=0 Then Input:='L';
a.ARea_type:=UpCase(Input[1]);
if not (a.area_type in [ 'L' ,'B' , 'G' ] ) then
A.Area_Type := 'L' ;
if (a.area_type in ['G' , 'B'] )Then
Begin
ANSiGoToXy(12,5);
writestr(^P'Group List File Name ['^S'CR/None'^P']:');
If Length(Input)=0 Then Input:='None';
a.File_List:=Input;
End
Else
A.File_List:='None' ;
if (a.area_type in ['L' , 'B'] )Then}
Begin
movexy(12,3);
writestr(^P'Access Level: *');
If Length(Input)=0 Then exit;
a.level:=valu(Input);
End
{Else
a.level := 0};
movexy(12,4);
writestr(^P'Allow Uploads? ['^S'Y'^P']: *');
if yes then begin a.upload:=true; printxy (32,4,^U+'Yes') end
else begin a.upload:=false; printxy (32,4,^U+'No '); end;
movexy(12,5);
writestr(^P'Allow Downloads? ['^S'Y'^P']: *');
if yes then begin a.download:=true; printxy (34,5,^U+'Yes') end
else begin a.download:=false; printxy (34,5,^U+'No '); end;
if num>1 then begin
movexy(12,6);
writestr(^P'Area Password ['^S'CR/None'^P']: *');
if input='N' then a.areapw:='' else
If Length(Input)=0 Then a.areapw:='' else
if Length(input)>0 then a.areapw:=upstring(input);
end else a.areapw:='';
movexy (12,7);
writestr(^P'Co-SysOp/Sponsor ['^S+unam+^P']: *');
If Length(Input)=0 Then Input:=unam;
a.sponsor:=Input;
movexy (12,8);
a.xmodemdir:=getapath; end else begin
writestr ('Area Name: &');
if length(input)=0 then exit;
a.name:=input;
writestr ('Access Level:');
if length(input)=0 then exit;
a.level:=valu(input);
writestr ('Sponsor [CR/'+unam+']:');
if length(input)=0 then input:=unam;
a.sponsor:=input;
writestr ('Entry Password [CR/None]:');
if length(input)=0 then a.areapw:='' else
a.areapw:=input;
writestr ('Able to Upload into this area? [CR/Yes]:');
if (length(input)=0) or (upcase(input[1])='Y') then
a.upload:=true else a.upload:=false;
writestr ('Able to Download from this area? [CR/Yes]:');
if (length(input)=0) or (upcase(input[1])='Y') then
a.download:=true else a.download:=false;
a.xmodemdir:=getapath;
end;
seekafile(num);
Write(afile,a);
area:=a;
curarea:=num;
assignud;
Rewrite(udfile);
WriteLn(^M^M^R'Area Created');
makearea:=True;
writelog(15,4,a.name)
End
End;
procedure setarea (n:integer);
var t:text;
l:string;
procedure nosucharea;
begin
writeln (^B'Invalid File Area!')
end;
begin
curarea:=n;
if (n>numareas) or (n<1) then begin
nosucharea;
if issysop
then if makearea
then setarea (curarea)
else setarea (1)
else setarea (1);
exit
end;
seekafile (n);
read (afile,area);
{ if area.usegroup then begin
assign (t,datadir+area.groupfn);
reset (t);
repeat
readln (t,l);
write ('Please Wait.');
until (eof(t)) or (match(l,unam));
write ('Uh Huh.');
if (match(unam,l)) then setarea (curarea)
else nosucharea;
end else }
if (urec.udlevel<area.level) and (not issysop)
then if curarea=1
then error ('User can''t access first area','','')
else
begin
nosucharea;
setarea (1);
exit
end;
if length(area.areapw)>0 then begin
writeln;
writestr ('[Entry Password]: *');
if length(input)=0 then begin setarea(1); end;
if not match(input,area.areapw) then begin setarea (1); end;
end;
assignud;
close (t);
close (udfile);
reset (udfile);
if ioresult<>0 then rewrite (udfile);
{writeln (^R^M'Area: '^S,area.name,^R' ['^S,curarea,^R']');
if sponsoron then writeln (^R'['^S'%'^R']:Xfer Sponsor Commands');
writeln;}
end;
procedure setarea2 (n:integer);
var t:text;
l:string;
procedure nosucharea;
begin
writeln (^B'Invalid File Area!')
end;
begin
curarea:=n;
if (n>numareas) or (n<1) then begin
nosucharea;
if issysop
then if makearea
then setarea2 (curarea)
else setarea2 (1)
else setarea2 (1);
exit
end;
seekafile (n);
read (afile,area);
{ if area.usegroup then begin
assign (t,datadir+area.groupfn);
reset (t);
repeat
readln (t,l);
write ('Please Wait.');
until (eof(t)) or (match(l,unam));
write ('Uh Huh.');
if (match(unam,l)) then setarea2 (curarea)
else nosucharea;
end else }
if (urec.udlevel<area.level) and (not issysop)
then if curarea=1
then error ('User can''t access first area','','')
else
begin
nosucharea;
setarea2 (1);
exit
end;
if length(area.areapw)>0 then begin
writeln;
writestr ('[Entry Password]:');
if length(input)=0 then exit;
if not match(input,area.areapw) then begin exit; exit; end;
end;
assignud;
close (t);
reset (udfile);
if ioresult<>0 then rewrite (udfile);
writeln (^B^M'Area: '^S,area.name,^R' ['^S,curarea,^R']');
if sponsoron then writeln (^R'['^S'%'^R']:Xfer Sponsor Commands');
writeln;
end;
procedure spacelen(le:byte);
var aaa:byte;
begin
for aaa:=1 to le do
write(' ');
end;
procedure linelen(le:byte);
var aaa:byte;
begin
for aaa:=1 to le do
write('─');
end;
Procedure toplinearea;
begin
if asciigraphics in urec.config then begin
writeln (^R'┌───┬───────────────────────────────────────┬───────┬─────┬─────┐');
writeln (^R'│ '^S'#'^R' │ '^S'Area Name'^R' │ '^S'Level'^R' │ '^S'U/L'^R' │ '
+^S'D/L'^R' │');
writeln (^R'├───┼───────────────────────────────────────┼───────┼─────┼─────┤');
end else begin
writeln (^R'+---+---------------------------------------+-------+-----+-----+');
writeln (^R'| '^S'#'^R' | '^S'Area Name'^R' | '^S'Level'^R' | '^S'U/L'^R' | '
+^S'D/L'^R' |');
writeln (^R'|---|---------------------------------------|-------|-----|-----|');
end;
end;
Procedure bottomlinearea;
begin
if asciigraphics in urec.config then
writeln (^R'└───┴───────────────────────────────────────┴───────┴─────┴─────┘')
else
writeln (^R'+---+---------------------------------------+-------+-----+-----+');
end;
procedure listareas;
var a:arearec;
c,k:integer;
cnt:integer;
begin
k:=0;
if exist (textfiledir+'Filearea.'+strr(conn)) then
printfile (textfiledir+'Filearea.'+strr(conn)) else
begin
writehdr ('File Area List');
seekafile (1);
toplinearea;
for cnt:=1 to numareas do begin
read (afile,a);
if a.level<=urec.udlevel
then begin
if asciigraphics in urec.config then
write (^R'│'^S,cnt) else write (^R'|'^S,cnt);
spacelen(3-length(strr(cnt)));
if asciigraphics in urec.config then
write (^R'│ '^S,a.name,^R) else write (^R'| '^S,a.name,^R);
spacelen(38-length(a.name));
if asciigraphics in urec.config then
write (^R'│'^S,a.level,^R) else write(^R'|'^S,a.level,^R);
spacelen(7-length(strr(a.level)));
if a.upload then
if asciigraphics in urec.config then
write(^R'│ '^S'Yes ') else write(^R'| '^S'Yes ')
else
if asciigraphics in urec.config then
write(^R'│ '^S'No ') else write(^R'| '^S'Yes ');
if a.download then
if asciigraphics in urec.config then
writeLn(^R'│ '^S'Yes'^R' │') else writeln(^R'| '^S'Yes'^R' |')
else
if asciigraphics in urec.config then
writeLn(^R'│ '^S'No'^R' │') else writeln(^R'| '^S'No'^R' |')
end;
if break then exit
end;
end;
bottomlinearea;
{}writeln;{}
end;
function getareanum:integer;
var areastr:sstr;
areanum:integer;
begin
getareanum:=0;
if length(input)>1
then areastr:=copy(input,2,255)
else begin
repeat
writestr ({^M}'Area Number [?/List]:');
if input='?' then listareas else areastr:=input
until (input<>'?') or hungupon;
end;
if length(areastr)=0 then exit;
areanum:=valu(areastr);
if (areanum>0) and (areanum<=numareas)
then getareanum:=areanum
else begin
writestr ('No such area!');
if issysop then if makearea then getareanum:=numareas
end;
end;
procedure getarea;
var areanum:integer;
begin
areanum:=getareanum;
if areanum<>0 then setarea (areanum);
end;
function getfname (path:lstr; name:mstr):lstr;
var l:lstr;
begin
l:=path;
if length(l)<>0
then if not (l[length(l)] in [':','\'])
then l:=l+'\';
l:=l+name;
getfname:=l
end;
Procedure topfileline;
begin;
if not (ffname in urec.filelister) and not (ffext in urec.filelister) and
not (ffsize in urec.filelister) and not (ffpoints in urec.filelister) and
not (ffuploader in urec.filelister) and not (ffuploaded in urec.filelister) and
not (ffdown in urec.filelister) and not (fffulnam in urec.filelister) and
not (ffofwhat in urec.filelister) then begin
urec.filelister:=urec.filelister+[ffname];
urec.filelister:=urec.filelister+[ffext];
urec.filelister:=urec.filelister+[ffsize];
urec.filelister:=urec.filelister+[ffpoints];
urec.filelister:=urec.filelister+[fffulnam];
urec.filelister:=urec.filelister+[ffofwhat];
writeurec;
end;
if asciigraphics in urec.config then begin
write (^S'# ');
if ffname in urec.filelister then write ('Filename ');
if ffext in urec.filelister then write ('Ext ');
if ffsize in urec.filelister then write ('Size ');
if ffpoints in urec.filelister then write ('Cost ');
if ffuploader in urec.filelister then write ('Uploader ');
if ffuploaded in urec.filelister then write ('Uploaded ');
if ffdown in urec.filelister then write ('Dl ');
if fffulnam in urec.filelister then write ('Program Description ');
if ffofwhat in urec.filelister then write ('Disk ');
writeln;
writeln (^R'───────────────────────────────────────────────────────────────────────────────');
end else begin
write (^S'# ');
if ffname in urec.filelister then write ('Filename ');
if ffext in urec.filelister then write ('Ext ');
if ffsize in urec.filelister then write ('Size ');
if ffpoints in urec.filelister then write ('Cost ');
if ffuploader in urec.filelister then write ('Uploader ');
if ffuploaded in urec.filelister then write ('Date U/L ');
if ffdown in urec.filelister then write ('Dl ');
if fffulnam in urec.filelister then write ('Program Description ');
if ffofwhat in urec.filelister then write ('Disk ');
writeln;
writeln (^R'-------------------------------------------------------------------------------');
end;
end;
Procedure bottomfileline;
begin
if asciigraphics in urec.config then
writeln (^R'───────────────────────────────────────────────────────────────────────────────')
else
writeln (^R'-------------------------------------------------------------------------------');
end;
procedure yourpcrstats;
var xx:real; x1:string[30];
begin
if urec.numon>0 then xx:=(urec.nbu div urec.numon) * 100 else
xx:=0.00;
printxy(30,8,streal(xx)+'%');
printxy(30,9,strr(urec.nbu));
if urec.numon>0 then printxy(30,10,strr(urec.numon)) else
printxy(30,10,strr(0));
end;
procedure yourudstatus;
var cnt,newfilez:integer; blah:integer; udr:real;
begin
if exist (textfiledir+'XferStat.Ans') or
exist (textfiledir+'XferStat.Asc') or exist (textfiledir+'XferStat.')
then begin show_all_info(textfiledir+'XferStat',getlastcaller,cnt);
end else begin
clrscr; gotoxy(1,1);
if (ansigraphics in urec.config) then write (#27+'[2J') else write (^L);
if asciigraphics in urec.config then begin
writeln(^P'┌─────────────┬───────────────────┐');
writeln(^P'│ '^R'File Level'^P': │ │┌────────────────────────────────────┐');
writeln(^P'│ '^R'File Points'^P':│ ││ │');
writeln(^P'│ '^R'Uploads'^P': │ │├────────────────────────────────────┤');
writeln(^P'│ '^R'Downloads'^P': │ ││ '^R'Operation Hrs'^P': │');
writeln(^P'│ '^R'New Files'^P': │ │└────────────────────────────────────┘');
writeln(^P'└─────────────┼─────────────┬─────┴─────────────┐');
writeln(^P' │ '^R'P'^P'/'^R'C Ratio'^P': │ │');
writeln(^P' │ '^R'Posts'^P': │ │');
writeln(^P' │ '^R'# Calls'^P': │ │');
writeln(^P' │ '^R'U'^P'/'^R'D Ratio'^P': │ │');
writeln(^P' │ '^R'Your Rating'^P':│ │');
writeln(^P' │ '^R'Average CPS'^P':│ │');
writeln(^P' └─────────────┴───────────────────┘');
printxy(16,2,^S+strr(urec.udlevel));
printxy(16,3,^S+strr(urec.udpoints));
printxy(16,4,strr(urec.uploads)+^P+' ['+^S+streal(urec.upk/1024)+'k'^P']');
printxy(16,5,strr(urec.downloads)+^P+' ['+^S+streal(urec.downk/1024)+'k'^P']');
newfilez:=(ups-urec.lastups);
if newfilez<1 then printxy(16,6,^S'None') else begin;
printxy(16,6,^S+strr(newfilez));
urec.lastups:=ups;
end;
yourpcrstats;
if urec.downloads > 0 then udr:=(urec.uploads div urec.downloads)*100 else
udr:=(urec.uploads)*100;
printxy(30,11,^S+streal(udr)+'%');
if useqr then begin
calcqr;
printxy(30,12,^S+strr(qr));
end else printxy(30,12,^S+'Not used.');
printxy(30,13,^S+strr(urec.averagecps));
printxy(38,3,^S+'Transfer Area');
if (xmodemopentime = xmodemclosetime) then printxy(53,5,^S'Always!') else
printxy(53,5,^S+xmodemopentime+^R+' to '+^S+xmodemclosetime);
urec.averagecps:=baudrate div 10;
end else begin
writeln(^P'+-------------+-------------------+');
writeln(^P'| '^R'File Level'^P': | |+------------------------------------+');
writeln(^P'| '^R'File Points'^P':| || |');
writeln(^P'| '^R'Uploads'^P': | |+------------------------------------|');
writeln(^P'| '^R'Downloads'^P': | || '^R'Operation Hrs'^P': |');
writeln(^P'| '^R'New Files'^P': | |+------------------------------------+');
writeln(^P'+-------------+-------------+-----+-------------+');
writeln(^P' | '^R'P'^P'/'^R'C Ratio'^P': | |');
writeln(^P' | '^R'Posts'^P': | |');
writeln(^P' | '^R'# Calls'^P': | |');
writeln(^P' | '^R'U'^P'/'^R'D Ratio'^P': | |');
writeln(^P' | '^R'Your Rating'^P':| |');
writeln(^P' | '^R'Average CPS'^P':| |');
writeln(^P' +-------------+-------------------+');
printxy(16,2,^S+strr(urec.udlevel));
printxy(16,3,^S+strr(urec.udpoints));
printxy(16,4,strr(urec.uploads)+^P+' ['+^S+streal(urec.upk/1024)+'k'^P']');
printxy(16,5,strr(urec.downloads)+^P+' ['+^S+streal(urec.downk/1024)+'k'^P']');
newfilez:=(ups-urec.lastups);
if newfilez<1 then printxy(16,6,^S'None') else begin;
printxy(16,6,^S+strr(newfilez));
urec.lastups:=ups;
end;
yourpcrstats;
if urec.downloads > 0 then udr:=(urec.uploads div urec.downloads)*100 else
udr:=(urec.uploads)*100;
printxy(30,11,^S+streal(udr));
if useqr then begin
calcqr;
printxy(30,12,^S+strr(qr));
end else printxy(30,12,^S+'Not used.');
printxy(30,13,^S+strr(urec.averagecps));
printxy(38,3,^S+'Transfer Area');
if (xmodemopentime = xmodemclosetime) then printxy(53,5,^S'Always!') else
printxy(53,5,^S+xmodemopentime+^R+' to '+^S+xmodemclosetime);
urec.averagecps:=baudrate div 10;
end;
movexy (1,15);
end;
pause;
writeln (^M);
end;
procedure getfsize (var ud:udrec);
var df:file of byte;
begin
ud.filesize:=-1;
assign (df,getfname(ud.path,ud.filename));
reset (df);
if ioresult<>0 then exit;
ud.filesize:=filesize(df);
close(df);
end;
procedure addfile (ud:udrec);
begin
seekudfile (numuds+1);
write (udfile,ud);
end;
procedure getconpw;
begin
if (length(confxpw[1])>0) and (conn=1) and not (issysop) then begin
echodot:=true;
writestr (^M^P'['^R'Conference #1 Password'^P']: *');
echodot:=false;
if not (match(input,confxpw[1])) then begin exit; exit; end;
end;
if (length(confxpw[2])>0) and (conn=2) and not (issysop) then begin
echodot:=true;
writestr (^M^P'['^R'Conference #2 Password'^P']: *');
echodot:=false;
if not (match(input,confxpw[2])) then begin exit; exit; end;
end;
if (length(confxpw[3])>0) and (conn=3) and not (issysop) then begin
echodot:=true;
writestr (^M^P'['^R'Conference #3 Password'^P']: *');
echodot:=false;
if not (match(input,confxpw[3])) then begin exit; exit; end;
end;
if (length(confxpw[4])>0) and (conn=4) and not (issysop) then begin
echodot:=true;
writestr (^M^P'['^R'Conference #4 Password'^P']: *');
echodot:=false;
if not (match(input,confxpw[4])) then begin exit; exit; end;
end;
if (length(confxpw[5])>0) and (conn=5) and not (issysop) then begin
echodot:=true;
writestr (^M^P'['^R'Conference #5 Password'^P']: *');
echodot:=false;
if not (match(input,confxpw[5])) then begin exit; exit; end;
end;
end;
procedure pointreassign;
var c:char;
procedure assignp;
var i,cnt:integer;
udd:udrec;
begin
for i:=1 to numuds do begin
seekudfile (i);
read (udfile,udd);
getfsize(udd);
if udd.filesize=-1 then writestr ('Warning: Can''t open file!');
if not (udd.filesize=-1) then
udd.points:=(udd.filesize div pointvalue div 1024);
tab (^S+strr(i),4);
tab (^S+udd.filename,13);
tab (^S+strlong(udd.filesize),10);
writeln;
writeln (^R'Cost set to '^S+strr(udd.points)+^R' points.');
seekudfile (i);
write (udfile,udd);
assignud;
end;
end;
procedure assignps;
var i,cnt:integer;
a:arearec;
begin
cnt:=curarea;
for i:=1 to numareas do begin
seekafile (i);
read (afile,a);
writeln (^R'Area #'^S+strr(i));
assignp;
end;
curarea:=cnt;
end;
begin
writehdr ('Point Re-Assign');
repeat
buflen:=1;
writestr (^S'T'^R'his Area '^S'A'^R'll Areas '^S'Q'^R'uit'^P': '^U'*');
c:=upcase(input[1]);
if (length(c)<1) or (c='Q') then exit;
case c of
'T':assignp;
'A':assignps;
end;
until (length(c)>0);
end;